;;;; Roger.lisp

#| DESCRIPTION:  Roger  is  a  simple AI to simulate a
Rogerian psychologist. Roger has a  small  knowledge  
base  represented by a production  system  which  parses  
English. The  parsing function utilizes a simplified 
wildcard logic with which to remember words long enough 
to regurgitate them. |#

(defpackage #:roger
  (:use #:cl)
  (:export #:roger
           #:match))

(in-package #:roger)

;;; Rogerian style head shrinking!
;;; top level function.
(defun roger ()
  "ROGER is the top-level function."

    (let ((wword-count 0) ; count question words.
          (punt-count 0)  ; count punt responses.
          s               ; mapped input sentence.
          b)              ; match bindings.

      (macrolet ((bind (msg) `(setf b (match ,msg s)))) 
        (symbol-macrolet ((interogative (progn
                                          (incf wword-count)
                                          (wword wword-count)))
                          (punt          (progn
                                           (incf punt-count)
                                           (format t "~a" (punt-it punt-count))))) 

          (format t "WELCOME TO MY SOFA!~%")
          (format t "PLEASE ENCLOSE YOUR WORDS IN PARENTHESES.~%")

          (loop (setf s (1st-2nd-map (read)))
                (terpri)
                (cond ((match '(bye) s)
                       (return 'goodbye))

                      ((bind '(you are *))
                       (print-s `(please tell me ,interogative ,@b)))

                       ((bind '(you have *))
                        (print-q `(how long have you had ,@(cddr b))))

                       ((match '(you feel *) s)
                        (format t "I SOMETIMES FEEL THE SAME WAY~%"))

                       ((match '(Because *) s)
                        (format t "IS THAT REALLY THE REASON?~%"))

                       ((bind '(yes *))
                        (print-q `(how can you be so sure ,@(cdr b))))

                       ((bind '(me are *))
                        (print-s `(Oh yeah I am ,@(cddr b))))

                       ((bind '(verbp *))
                        (print-q `(Why do you want me to ,@b)))

                       ((bind '(wpred *))
                        (print-s `(You tell me ,(car b))))

                       ((bind '(dpred i *))
                        (print-s `(perhaps I ,(car b) ,@(cdddr b))))

                       ((or (member 'dream s) (member 'dreams s))
                        (format t "FOR DREAM ANALYSIS SEE FREUD."))

                       ((member 'maybe s)
                        (format t "BE MORE DECISIVE!"))

                       ((member 'you s)
                        (print-s s))

                       (t punt)))))))


;;; MATCH list P with list S.
;;;   ? match any 0 or 1
;;;   * match any 0 or more.
;;;   Wildcards are non-greedy.
(defun match (p s)
  "Match EQL symbols and wildcards ? and *."
  (labels ((self (p s acc)
             (symbol-macrolet
                 ((collect     (push that acc))
                  (recur       (self (rest p) (rest s) acc))
                  (continue    (self       p  (rest s) acc))
                  (skip        (self (rest p)       s  acc))
                  (test-next   (self (rest p)       s  nil))
                  (match-0     skip)
                  (match-1     (progn collect recur))
                  (match-multi (progn collect continue)))

               (let ((this (first p))
                     (that (first s)))

                 ;; At end of both lists, ret acc.
                 (cond ((and (null p) (null s))
                        acc)

                       ;; If match or ? wildcard, collect.
                       ((member this `(? ,that))
                        match-1)

                       ;; If * wildcard, test if remainder
                       ;;   of lists match were * not in
                       ;;   in list. If so, skip. Otherwise,
                       ;;   continue this same test on rest
                       ;;   of S.
                       ((eql this '*)
                        (cond ((and (rest p) (null s)) nil)
                              ((null s) acc)
                              (test-next match-0)
                              (t match-multi)))

                       ;; If (THIS THAT) == T, then collect.
                       ((and (member this '(wpred dpred verbp))
                             (apply this (list that)))
                        match-1)

                       (t nil))))))
    (nreverse (self p s nil))))


;;; HELPERS

;;; print each item in a list.
(defun printl (message)
  (mapcar #'(lambda (txt)
              (format t "~a " txt))
          message))

;;; print list ending with .
(defun print-s (message)
  (printl (butlast message))
  (format t "~a." (car (last message)))
  (terpri))

;;; print list ending with ?
(defun print-q (message)
  (printl (butlast message))
  (format t "~a?" (car (last message)))
  (terpri))

;;; Swap 1st and 2nd person words.
(defun 1st-2nd-map (lst)
  (mapcar #'(lambda (w)
              (cond
                ((member w '(i me)) 'you)
                ((eql w 'you)   'me)
                ((eql w 'your)  'my)
                ((eql w 'my)    'your)
                ((eql w 'yours) 'mine)
                ((eql w 'mine)  'yours)
                ((eql w 'am)    'are)
                (t w)))
          lst))

(defun verbp (w)
  (member w '(go have be try eat take help make
              get jump write type fill put turn
              compute think drink blink crash
              crunch add)))

(defun wpred (w)
  (member w '(who what where when why how)))

(defun wword (n)
  (nth (mod n 4) '(when why whre how)))

(defun dpred (w)
  (member w '(do can should would)))

;;; Return one of six punts.
(defun punt-it (punt-count)
  (nth (mod punt-count 6)
       '("PLEASE GO ON."
         "TELL ME MORE."
         "I SEE."
         "WHAT DOES THAT INDICATE?"
         "BUT WHY BE CONCERNED ABOUT IT?"
         "JUST TELL ME HOW YOU FEEL.")))
